home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 May: Tool Chest / Developer CD Series May 1996 (Tool Chest) (Apple Computer) (1996).iso / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / 2.01 sources / Library-2.01 / help-manager.lisp < prev    next >
Encoding:
Text File  |  1993-09-16  |  29.1 KB  |  694 lines  |  [TEXT/CCL2]
  1. ;-*- Mode: Lisp; Package: CCL -*-
  2. ; help-manager.lisp
  3.  
  4. (in-package :ccl)
  5.  
  6. ;; 04/28/93 mwp Release
  7. ;; 01/07/93 bill Fix missing descenders bug by setting fontascent & lineheight in help-tehandle
  8. ;; 11/09/92 bill checked-help-string
  9. ;; 11/02/92 bill menu-hmnu-id is no more.
  10. ;;-------------- 2.0
  11. ;; 11/12/91 bill Changed WINDOW... to WindowRecord... Put $menuList at :compile-toplevel. (from dds)
  12. ;; 10/29/91 bill a help-spec can be an integer, denoting the 'STR ' resource of that number
  13. ;;               functional help-specs for menu items
  14. ;; 07/05/91 bill With Randy Carr's help, fix missing descenders on bottom line of
  15. ;;               menu-item help.
  16. ;;               Add MBAR defproc handling to get menubar help.
  17. ;; 06/18/91 bill Works for menu items now.
  18. ;;               deepest-view-contained-by-me-below-mouse -> find-clicked-subview
  19. ;;               speed window-null-event-handler up a little bit, though
  20. ;;               system 7 seems to steal most of the machine when help is on.
  21. ;; 4/29/91 bill *help-manager-present*, view-help-string -> help-string
  22. ;; Friday September 28,1990 0:25am - moved to #_ interface
  23. ;; Friday April 5,1991 2:25pm made it run again in 7.0b6
  24. ;; Friday April 5,1991 3:40pm make the check be on window-null-event-handler, instead of enter and leave.
  25.  
  26. ;;;****************************************************************
  27. ;; support for some of the help manager. The idea is that you define
  28. ;; a method for help-string for your view. Then, if help is enabled
  29. ;; a balloon will pop up with that string (computed at pop time).
  30. ;; the default method says something about views and their containers.
  31.  
  32. ;; Interface:
  33.  
  34. ;; (help-string view)      -> the string for the view that should appear in the help balloon
  35. ;; (help-tip-point view)   -> The point where the tip of the balloons should be. Defaults to where the mouse is
  36. ;; (set-help state)        -> Turn balloon help on or off (t or nil)
  37. ;; (help-on?)              -> returns t or nil
  38. ;;  help-always-on-mixin   -> Mix into a view to make help always be on in that view
  39. ;; *view-nesting-help*     -> If t then when help is on, default method for view help string tells something
  40. ;;                            about the view container hierarchy of the view. Initially t
  41.  
  42. (eval-when (:compile-toplevel :load-toplevel :execute)
  43.   (require "RESOURCES")
  44.   
  45.   (export '(view-help-event-handler help-string help-on? set-help 
  46.             help-tip-point help-always-on-mixin
  47.             help-spec)))
  48.  
  49. ;; Here is an example of an extension for fred windows
  50. (defmethod help-string ((f fred-window))
  51.   (or (help-resource-string f)
  52.       "This is a Fred window. Fred deliberately resembles Emacs. Fred is your friend."))
  53.  
  54. (defmethod help-string ((l listener))
  55.   (or (help-resource-string l)
  56.       "This is a Lisp listener.  Enter a Lisp expression and it will be evaluated."))
  57.  
  58. ;;;****************************************************************
  59. ;; globals
  60.  
  61. (defvar *view-with-balloon* nil "The view that has a help balloon on top of it now")
  62. (defvar *view-nesting-help* t "Set to have descriptions of views when help is on")
  63.  
  64. ;;;****************************************************************
  65. ;; view info help strings
  66.  
  67. ; The help-string method always returns a string.
  68. ; The default method looks for a help-spec and returns its string.
  69. (defmethod help-string (thing)
  70.   (help-resource-string thing))
  71.  
  72. (defvar *help-resource-file-refnum* nil)
  73.  
  74. ; Specialize this if you store your help resources in a different file
  75. (defmethod help-resource-file ((a application))
  76.   (get-doc-string-file t))
  77.  
  78. ; Specialize this if you store your help resources in your application's resource fork
  79. (defmethod help-resource-file-refnum ((a application))
  80.   (or *help-resource-file-refnum*
  81.       (let ((file (help-resource-file a)))
  82.         (and file
  83.              (setq *help-resource-file-refnum*
  84.                    (using-resource-file (current-resource-file)
  85.                      (open-resource-file file :errorp nil)))))))
  86.  
  87. (defun close-help-resource-file ()
  88.   (let ((refnum *help-resource-file-refnum*))
  89.     (when refnum
  90.       (setq *help-resource-file-refnum* nil)
  91.       (close-resource-file refnum))))
  92.  
  93. (pushnew 'close-help-resource-file *lisp-cleanup-functions*)
  94.  
  95. ; This is where the parsing of the help-spec happens
  96. (defun help-resource-string (thing &aux refnum)
  97.   (labels ((resolve-restype (restype thing)
  98.              (cond ((null restype) nil)
  99.                    ((stringp restype) restype)
  100.                    ((or (functionp restype) (symbolp restype))
  101.                     (resolve-restype (funcall restype thing) thing))
  102.                    ((and (or (integerp restype) (listp restype))
  103.                          (setq refnum (help-resource-file-refnum *application*))
  104.                          (using-resource-file refnum
  105.                            (block foo
  106.                              (return-from resolve-restype
  107.                                (cond ((integerp restype)
  108.                                       (get-string restype))
  109.                                      ((null (cdr restype))
  110.                                       (get-string (car restype)))
  111.                                      ((and (listp (cdr restype)) (null (cddr restype)))
  112.                                       (get-ind-string (car restype) (cadr restype)))
  113.                                      (t (return-from foo nil))))))))
  114.                    (t (error "Malformed help-spec: ~s" restype)))))
  115.     (resolve-restype (help-spec thing) thing)))
  116.  
  117. ; help-spec can return the following types of values:
  118. ;
  119. ; NIL
  120. ;   this thing has no help resource.
  121. ; a string
  122. ;   The string is the help string.
  123. ; A function or symbol
  124. ;   The help-spec is the result of funcalling the function or symbol
  125. ;   with the object as the single argument.
  126. ; A list of the form (name-or-number) or a number
  127. ;   There is a 'STR ' resource whose name or number is the car of the list
  128. ; a list of the form (name-or-number index)
  129. ;   There is a 'STR#' resource with the given name or number.
  130. ;   The help string is the INDEX'th string in that resource.
  131.  
  132. (defmethod help-spec (thing)
  133.   (declare (ignore thing))
  134.   nil)
  135.  
  136. (defmethod help-spec ((view simple-view))
  137.   (view-get view :help-spec))
  138.  
  139. (defmethod (setf help-spec) (spec (view simple-view))
  140.   (setf (view-get view :help-spec) spec))
  141.  
  142. ; Menus and menu-items have a HELP-SPEC slot
  143.  
  144. ; Unless the user provides a help-spec method, the default
  145. ; help-string for a simple-view is the view nesting help.
  146. (defmethod help-string ((v simple-view))
  147.   (or (help-resource-string v)
  148.       (and *view-nesting-help*
  149.            (let ((help-string (make-string-output-stream)))
  150.              (view-container-info v help-string "This is ")
  151.              (format help-string ".")
  152.              (coerce (string-output-stream-string help-string)
  153.                      'simple-string)))))
  154.  
  155. (defmethod view-container-info ((v simple-view) stream &optional (intro " inside "))
  156.    (format stream intro)
  157.    (typecase v
  158.       (dialog (if (window-title v)
  159.                     (format stream "the dialog ~s (type ~A)"
  160.                                  (window-title v)
  161.                                  (string-capitalize (type-of v)))
  162.                     (format stream "a dialog of type ~A"
  163.                                  (string-capitalize (type-of v)))))
  164.       (window (if (window-title v)
  165.                       (format stream "the window ~s (type ~A)"
  166.                                    (window-title v)
  167.                                    (string-capitalize (type-of v)))
  168.                       (format stream "a window of type ~A"
  169.                                    (string-capitalize (type-of v)))))
  170.       (t (format stream "a view of type ~A" (string-capitalize (type-of v)))))
  171.    (when (view-container v)
  172.        (view-container-info (view-container v) stream)))
  173.  
  174. ;;;****************************************************************
  175. ;;  we use a textedit record here, since we need strings of arbitrary size.
  176.  
  177. (defparameter *help-tehandle*  nil)
  178. (defparameter *help-message-record* nil)
  179. ;; needs to be allocated and held, since the help manager can hold onto this for longer
  180. ;; than the body of an rlet
  181.  
  182. (def-ccl-pointers help-manager ()
  183.    (setq *help-tehandle* nil)
  184.    (setq *help-message-record* nil))
  185.  
  186. (defun help-tehandle (string &aux (length (length string)))
  187.    "returns a texthandle with string as it's string contents. There is one terec *help-tehandle*"
  188.    (let ((terec *help-tehandle*)
  189.          font size)
  190.      (if terec
  191.        ; Necessary because bug in system neglects to initialize these.
  192.        (setf (href terec :terec.destrect.topleft) #@(5 5)
  193.              (href terec :terec.destrect.botRight) #@(100 100)
  194.              (href terec :terec.viewrect.topleft) #@(5 5)
  195.              (href terec :terec.viewrect.botRight) #@(100 100))
  196.        (rlet ((r :rect
  197.                  :topleft #@(5 5)
  198.                  :bottomright #@(100 100)))
  199.          (setq *help-tehandle* (setq terec (#_tenew r r)))))
  200.      (rlet ((font-info :integer))
  201.        (#_HMGetFont font-info)
  202.        (setf (href terec :terec.txfont)
  203.              (setq font (%get-word font-info)))
  204.        (#_HMGetFontSize font-info)
  205.        (setf (href terec :terec.txsize)
  206.              (setq size (%get-word font-info)))
  207.        (setf (href terec :terec.txmode) 0)
  208.        (setf (href terec :terec.txface) 0))
  209.      (multiple-value-bind (ascent descent maxwid leading)
  210.                           (font-codes-info (make-point 0 font) (make-point size 0))
  211.        (declare (ignore maxwid))
  212.        (setf (href terec :terec.fontascent) ascent
  213.              ; maybe this should be just (+ ascent descent)
  214.              (href terec :terec.lineheight) (+ ascent descent leading)))
  215.      (with-cstr (cs string 0 length)
  216.        (#_tesettext cs length terec))
  217.      terec))
  218.  
  219. ; debugging
  220. (defun help-tehandle-string  ()
  221.   (and *help-tehandle*
  222.        (let ((str (#_tegettext :ptr *help-tehandle* :ptr)))
  223.          (%str-from-ptr (%get-ptr str) (href *help-tehandle* terec.telength)))))
  224.  
  225. (defmethod setup-help-message (string)
  226.    (unless *help-message-record*
  227.       (setq *help-message-record* (make-record :hmmessagerecord :hmmHelpType #$khmmtehandle)))
  228.    (rset *help-message-record* :hmmessagerecord.hmmTEHandle (help-tehandle string)))
  229.  
  230. ;;;****************************************************************
  231. ;;  Information about placement of balloon
  232.  
  233. (defmethod help-tip-point ((v simple-view))
  234.    (view-mouse-position v))
  235.  
  236. ;; save bits if the help window would be completely enclosed in the window. Customize this if you want.
  237. (defmethod help-save-bits? ((v simple-view))
  238.    (rlet ((balloonrect :rect))
  239.       (#_hmballoonrect :ptr *help-message-record* :ptr balloonrect :word)
  240.       (let ((wptr (wptr v)))
  241.          (rlet ((intersect :rect)
  242.                    (window-rect :rect
  243.                                 :topleft (pref wptr windowRecord.portrect.topleft)
  244.                                 :bottomright (pref wptr windowRecord.portrect.bottomright)
  245.                                 ))
  246.             (#_offsetrect :ptr balloonrect :long (view-mouse-position (view-window v)))
  247.             (#_sectrect window-rect balloonrect intersect)
  248.             (and
  249.               (= (pref intersect rect.topleft) (pref balloonrect rect.topleft))
  250.               (= (pref intersect rect.bottomright) (pref balloonrect rect.bottomright)))
  251.             ))))
  252.  
  253. ;;;****************************************************************
  254.  
  255. (defmethod remove-balloon ((v simple-view))
  256.    (when *view-with-balloon*
  257.        (let ((w (view-window v)))
  258.           (when (and (#_hmisballoon)
  259.                      (point<= #@(0 0) (view-mouse-position w) (view-size w)))
  260.               (#_hmremoveballoon))
  261.           (setq *view-with-balloon* nil))
  262.        (let ((w (view-window v)))
  263.           (and w (window-update-event-handler w)))))
  264.  
  265. (defmethod view-click-event-handler :before ((v simple-view) where)
  266.    (declare (ignore where))
  267.    (when *help-manager-present*
  268.      (#_hmremoveballoon))) 
  269.  
  270. ; Used to prevent menubar help from thrashing
  271. (defvar *last-help-item* nil)
  272.  
  273. ;; we pass no hot rect here, since leave event handler takes care of removing the balloon
  274. (defmethod show-balloon (thing tip save-bits)
  275.   (setq *last-help-item* thing)
  276.   (#_hmshowballoon  *help-message-record*
  277.    tip (%null-ptr)  (%null-ptr) 0 0
  278.    (if save-bits
  279.      (if (fixnump save-bits) save-bits #$khmsavebitsnowindow)
  280.      #$khmregularwindow)
  281.    ))
  282.  
  283. (defun checked-help-string (view)
  284.   (let ((string (help-string view)))
  285.     (when string
  286.       (setq string (string string))
  287.       (unless (eql 0 (length string))
  288.         string))))    
  289.  
  290. (defmethod view-put-up-balloon ((v simple-view) &optional string)
  291.    (when (not (#_hmgetballoons :boolean)) (return-from view-put-up-balloon nil))
  292.    (multiple-value-bind (string save-bits)
  293.                                    (or string (checked-help-string v))
  294.        (when string ;; null means that we don't want help
  295.            (setup-help-message string)
  296.            (let* ((tip (with-focused-view v
  297.                          (%local-to-global (wptr v) (help-tip-point v)))))
  298.               ;; make sure we are still in window
  299.               (let ((w (view-window v)))
  300.                  (when (not (point<= #@(0 0) (view-mouse-position w) (view-size w)))
  301.                      (return-from view-put-up-balloon)))
  302.               ;; check if we are still in the view
  303.               (when (eq v (find-clicked-subview v (view-mouse-position v)))
  304.                  ;; doobeedoo
  305.                  (let ((res (show-balloon
  306.                                   v tip
  307.                                   (and  save-bits (help-save-bits? v)))))
  308.                     (cond ((and (= res -852) save-bits)
  309.                                ; out of memory,  there isn't enough room on the heap. Try to show it without saving bits.
  310.                                (show-balloon v tip nil))
  311.                              ;; mouse moving too quickly just pass
  312.                              ((= res -853))
  313.                              ((minusp res)
  314.                                (rset *help-message-record*
  315.                                         :hmmessagerecord.hmmTehandle
  316.                                         (help-tehandle
  317.                                          (format nil "Help Manager Error: ~A" res)))
  318.                                (show-balloon v tip nil))
  319.                              ((zerop res)  (setq *view-with-balloon* v)))))))))
  320.  
  321.  
  322. ;;****************************************************************
  323. ;; do the check in window-null-event-handler. Originally I had it in on the enter and leave handlers,
  324. ;; but that was too flakey. For one thing, the enter handler gets called and the mouse may still be moving,
  325. ;; in which case the balloon manager punts. You want to check again in a little while to see if
  326. ;; the mouse has settled down. Also, the leave handler is called way after the mouse leaves, sometimes,
  327. ;; and you have to check if you are still in the content area of the window so as not to remove someone
  328. ;; else's balloons.
  329.  
  330. #|
  331. (defmethod window-null-event-handler :after ((w window))
  332.   (if (help-on?)
  333.     (show-mouse-view-balloon)
  334.     (setq *view-with-balloon* nil)))
  335. |#
  336.  
  337. ; This does the actual showing of the balloon
  338. ; Called by the window-null-event-handler method below
  339. (defun show-mouse-view-balloon ()
  340.   (let ((mouse-view *mouse-view*))
  341.     ;; if we go outside the content region, then another balloon has taken over, and we just return
  342.     (unless mouse-view
  343.       (setq *view-with-balloon* nil)
  344.       (return-from show-mouse-view-balloon))
  345.     ;; no balloon means someone else has put up a balloon or gotton rid of ours
  346.     (when (not (#_hmisballoon)) (setq *view-with-balloon* nil))
  347.     ;;if we are not in the same view as before, get rid of old, and put up new
  348.     (when (neq *view-with-balloon* mouse-view)
  349.       (#_hmremoveballoon)
  350.       (view-put-up-balloon mouse-view))))
  351.  
  352. ;;;****************************************************************
  353. ;; help state
  354.  
  355. ;; help-on? is defined by the resident part of MCL
  356.  
  357. (defun set-help (boolean)
  358.   (when *help-manager-present*
  359.     (without-interrupts
  360.      (when (null boolean) 
  361.        (#_hmremoveballoon)
  362.        (setq *view-with-balloon* nil))
  363.      (#_hmsetballoons boolean))))
  364.  
  365. ;;;****************************************************************
  366. ;; a mixin for views which always want to have help active.
  367.  
  368. (defclass help-always-on-mixin () ((help-state)))
  369.  
  370. (defmethod set-view-container :after ((v help-always-on-mixin)  ignore)
  371.   (declare (ignore ignore))
  372.   (setf (slot-value v 'help-state) (help-on?)))
  373.  
  374. (defmethod view-mouse-enter-event-handler :before ((v help-always-on-mixin))
  375.    (unless (slot-boundp v 'help-state)
  376.       (setf (slot-value v 'help-state) (help-on?)))
  377.    (set-help t)
  378.    )
  379.  
  380. (defmethod view-mouse-leave-event-handler :before ((v help-always-on-mixin))
  381.    (set-help (slot-value v 'help-state))
  382.    )
  383.  
  384. (defmethod view-deactive-event-handler :before ((v help-always-on-mixin))
  385.    (set-help (slot-value v 'help-state)))
  386.  
  387. (defmethod (setf wptr) :before (new-value (v help-always-on-mixin))
  388.    (when (and (null new-value) (slot-boundp v 'help-state))
  389.        (set-help (slot-value v 'help-state))
  390.        ))
  391.  
  392. ;;;****************************************************************
  393. ;; Help for menu-items
  394. ;;
  395.  
  396. ; HELP-SPEC's for menus & menu-items are a little more general than those
  397. ; for views.  In addition to strings, 'STR ' & 'STR#' resource specs, the
  398. ; help-spec for a menu-item can be of the form:
  399. ;
  400. ; (<type> enabled-spec disabled-spec &optional checked-spec other-spec)
  401. ;
  402. ; <type> can be:
  403. ;   :string - each of the xxx-spec's is a string
  404. ;   :|STR | - each of the xxx-spec's is the name or number of a 'STR ' resource
  405. ;   (:|STR#| name-or-number) or just a fixnum or string denoting the name-or-number
  406. ;             each of the xxx-spec's is the index of a string in
  407. ;             the 'STR#' resource with the given name-or-number
  408. ;
  409. ; In this case the enabled-spec is the help string for the menu-item when
  410. ; it is enabled, the disabled-spec when it is disabled, the checked-spec
  411. ; when it is enabled and checked, and the other-spec when it is enabled
  412. ; and has a marker that is not the check-mark.
  413. ;
  414. ; HELP-SPEC for a menu may return a specification for the menu's help
  415. ; string and the default help-string for all the menu-items.
  416. ; This is of the form (VALUES menu-spec default-spec).
  417. ; If the help-spec for a menu is not a list whose car is the symbol VALUES,
  418. ; then there is no default-spec, and the returned value is the menu-spec.
  419. ;
  420. ; Any menu-item that has no HELP-SPEC (for which HELP-SPEC returns the
  421. ; default of NIL) will use the default-spec.  If there is a default-spec
  422. ; and you want no help for a menu-item, return :SKIP as its HELP-SPEC.
  423.  
  424. (defmethod help-string ((item menu-item))
  425.   (let ((spec (help-spec item))
  426.         (state (if (menu-item-enabled-p item)
  427.                  (let ((check (menu-item-check-mark item)))
  428.                    (if check
  429.                      (if (eql #\CheckMark check) 2 3)
  430.                      0))
  431.                  1)))
  432.     (cond ((null spec)
  433.            (setq spec (help-spec (menu-item-owner item)))
  434.            (if (and (listp spec) (eq (car spec) 'values))
  435.              (%menu-help-string item (caddr spec) state)
  436.              nil))
  437.           ((eq spec :skip) nil)
  438.           (t (%menu-help-string item spec state)))))
  439.  
  440. (defmethod help-string ((menu menu))
  441.   (let ((spec (help-spec menu)))
  442.     (if (and (listp spec) (eq (car spec) 'values))
  443.       (setq spec (cadr spec)))
  444.     (when spec
  445.       (%menu-help-string menu spec (if (menu-enabled-p menu) 0 1)))))
  446.  
  447. (defun %menu-help-string (item spec &optional (state 0))
  448.   (labels ((refnum ()
  449.              (or (help-resource-file-refnum *application*) (current-resource-file)))
  450.            (str-item (&rest rest)
  451.              (using-resource-file (refnum)
  452.                (get-string (or (nth state rest) (car rest)) t)))
  453.            (str#-item (n &rest rest)
  454.              (using-resource-file (refnum)
  455.                (get-ind-string n (or (nth state rest) (car rest)) t)))
  456.            (string-item (&rest rest)
  457.              (or (nth state rest) (car rest)))
  458.            (malformed (spec)
  459.              (error "Malformed help-spec: ~s" spec)))
  460.     (declare (dynamic-extent #'str-item #'str-#item #'string-item))
  461.     (cond ((functionp spec) (%menu-help-string item (funcall spec item) state))
  462.           ((stringp spec) spec)
  463.           ((fixnump spec) (str-item spec))
  464.           ((and (listp spec) (null (cdr spec)))
  465.            (str-item (car spec)))
  466.           ((and (listp spec) (listp (cdr spec))
  467.                 (null (cddr spec)))
  468.            (str#-item (car spec) (cadr spec)))
  469.           ((and (listp spec) (<= 3 (length spec) 5))
  470.            (let ((car (car spec))
  471.                  (cdr (cdr spec))
  472.                  id)
  473.              (cond ((eq car :string)
  474.                     (apply #'string-item cdr))
  475.                    ((eq car :|STR |)
  476.                     (apply #'str-item cdr))
  477.                    ((or (and (listp car)
  478.                              (eq (car car) :|STR#|)
  479.                              (listp (cdr car))
  480.                              (null (cddr car))
  481.                              (setq id (cadr car)))
  482.                         (or (fixnump (setq id car)) (stringp car)))
  483.                     (apply #'str#-item id cdr))
  484.                    (t (malformed spec)))))
  485.           (t (malformed spec)))))
  486.  
  487. (defun show-balloon-string (thing string tip &optional (save-bits? t))
  488.   (setup-help-message string)
  489.   (show-balloon thing tip save-bits?))
  490.  
  491. (defvar *mbar-proc* nil)
  492.  
  493. (eval-when (:compile-toplevel :execute)
  494.   (let ((*warn-if-redefine* nil))
  495.     (defconstant $menuList #xa1c))
  496. )
  497.  
  498. (defun menu-edges (menu &optional (menu-handle (menu-handle menu)))
  499.   (with-macptrs ((menu-list (%get-ptr (%get-ptr (%int-to-ptr $menuList))))
  500.                  temp)
  501.     (let ((count (floor (%get-word menu-list) 6)))
  502.       (dotimes (i count)
  503.         (declare (fixnum i))
  504.         (%incf-ptr menu-list 6)
  505.         (%setf-macptr temp (%get-ptr menu-list))
  506.         (when (eql menu-handle temp)
  507.           (let ((left (%get-word menu-list 4))
  508.                 (width (with-font-codes 0 0
  509.                          (string-width (menu-title menu)))))
  510.             ; The six pixel spacing was determined by experiment
  511.             (return (values left (+ left 6 width 6)))))))))
  512.  
  513. ; MCL shows help strings for pointing at the menubar the same way the System
  514. ; help manager does: ask the Menu Bar Defproc which menu we're pointing at.
  515. ; See IM V-251 for documentation of the menubar defproc.
  516. ; This is called whether or not there is a window showing.
  517. (defmethod window-null-event-handler :after (w)
  518.   (declare (ignore w))
  519.   (when (and *foreground* (help-on?))
  520.     (let ((mbar-proc *mbar-proc*))
  521.       (unless (typep mbar-proc 'macptr)
  522.         (setq mbar-proc (setq *mbar-proc* (get-resource :MBDF 0))))
  523.       (when (typep mbar-proc 'macptr)
  524.         (without-interrupts
  525.          (let* ((mouse (view-mouse-position nil))
  526.                 (menu-index (ff-call (%get-ptr mbar-proc)
  527.                                      :word 0       ; mbVariant
  528.                                      :word 1       ; message #1: Hit
  529.                                      :word 0       ; parameter 1: ignored
  530.                                      :long mouse   ; parameter 2: mouse
  531.                                      :long
  532.                                      ))
  533.                 (last-help-item *last-help-item*))
  534.            (if (>= menu-index 6)        ; mouse in menubar
  535.              (let ((menu (nth (1- (floor menu-index 6)) %menubar)))
  536.                (when menu
  537.                  (unless (and (eq menu last-help-item) (#_hmIsBalloon))
  538.                    (setq *last-help-item* nil)
  539.                    (let ((string (checked-help-string menu)))
  540.                      (setq *view-with-balloon* nil)
  541.                      (if string
  542.                        (multiple-value-bind (left right) (menu-edges menu)
  543.                          (setq mouse (make-point (if left (ash (+ left right) -1)
  544.                                                      (point-h mouse))
  545.                                                  (%get-word (%int-to-ptr #$mbarHeight))))
  546.                          (show-balloon-string menu string mouse nil))
  547.                        (unless (eq menu *apple-menu*)
  548.                          (#_HmRemoveBalloon)))))))
  549.              (progn
  550.                (setq *last-help-item* nil)
  551.                (show-mouse-view-balloon)))))))))
  552.  
  553. ; MCL shows help strings for menu-items by patching the trap _hmShowMenuHelp
  554. ; which is called by the standard menu definition procedure.
  555.  
  556. #|
  557. ; This is the source code for the *hmShowMenuBalloon-patch* parameter below
  558.  
  559. (require "LAPMACROS")
  560.  
  561. (defun hmShowMenuBalloon-patch (&lap 0)
  562.   (lap
  563. @lisp-entry
  564.     (dc.w 0 0)
  565. @old-trap-address
  566.     (dc.w 0 0)
  567.     (if# (eq (cmp.w ($ 3589) d0))   ; selector for _hmShowMenuBalloon
  568. ;      (dc.w _debugger)
  569.       (movem.l #(d0 a0 a1) -@sp)
  570.       (sub.l ($ 30) sp)                 ; another stack frame
  571.       (lea @sp a1)
  572.       (lea (sp (+ 30 12 4)) a0)
  573.       (move.w ($ 15) d0)
  574.       (dbfloop d0 (move.w a0@+ a1@+))
  575.       (move.l (^ @lisp-entry) a0)
  576.       (jsr @a0)
  577.       (move.w sp@+ d0)
  578.       (if# (eq (add.w ($ 1) d0))        ; Returned #xffff: call the usual version
  579.         (movem.l sp@+ #(d0 a0 a1))
  580.         (bra @nopatch)
  581.        else#
  582.         (sub.w ($ 1) d0)
  583.         (move.l (sp 12) (sp (+ 12 4 24)))       ; return address
  584.         (move.w d0 (sp (+ 12 4 28)))    ; return value
  585.         (movem.l sp@+ #(d0 a0 a1))
  586.         (add.l ($ (+ 4 24)) sp)
  587.         (rts)))
  588. @nopatch
  589.     (spush (^ @old-trap-address))
  590.     (rts)))
  591.  
  592. (defun *hmShowMenuBalloon-patch* ()
  593.   (let* ((vector (%lfun-vector #'hmShowMenuBalloon-patch))
  594.          (patch-address (%address-of #'hmShowMenuBalloon-patch))
  595.          (offset (ash (- patch-address (+ (%address-of vector) 7)) -1))
  596.          (size (- (uvsize vector) offset))
  597.          (res (make-array size)))
  598.     (dotimes (i size)
  599.       (setf (aref res i) (uvref vector (+ offset i))))
  600.     res))
  601.  
  602. |#
  603.  
  604. (defparameter *hmShowMenuBalloon-patch*
  605.   (if (fboundp '*hmShowMenuBalloon-patch*)
  606.     (funcall '*hmShowMenuBalloon-patch*)
  607.     ; This is the vector returned by the *hmShowMenuBalloon-patch* function
  608.     #(0 0 0 0
  609.       -20356 3589 26184 18663 -32576 -24580 0 30 17367 16879 46 12348 15
  610.       24578 13016 20936 -4 8314 -44 20112 12319 21056 26120 19679 769
  611.       24602 24600 21312 12143 12 40 16192 44 19679 769 -8196 0 28 20085 12090
  612.       -84 20085 425 6292 424 1202 -23552 558)))
  613.  
  614. (defvar *last-item-menuid* nil)
  615. (defvar *last-item-num* nil)
  616.  
  617. (defpascal lisp-hmShowMenuBalloon (:word item-num       ;   2 =  2
  618.                                    :word item-menuid    ; + 2 =  4
  619.                                    :long item-flags     ; + 4 =  8
  620.                                    :long item-reserved  ; + 4 = 12
  621.                                    :long tip            ; + 4 = 16
  622.                                    :ptr alternate-rect  ; + 4 = 20
  623.                                    :ptr tip-proc        ; + 4 = 24
  624.                                    :word the-proc       ; + 2 = 26
  625.                                    :word variant        ; + 2 = 28
  626.                                    :word)               ; + 2 = 30 bytes on the stack
  627.   (declare (ignore alternate-rect item-reserved item-flags
  628.                    tip-proc the-proc variant))
  629.   (or (ignore-errors
  630.        (and (or (not (#_hmIsBalloon))
  631.                 (not (and (eql item-num *last-item-num*)
  632.                       (eql item-menuid *last-item-menuid*))))
  633.             (let ((menu (menu-object item-menuid)))
  634.               (setq *last-item-num* item-num
  635.                     *last-item-menuid* item-menuid)
  636.               (if menu
  637.                 (or (let* ((element (if (eql 0 item-num) 
  638.                                       (progn (#_hmRemoveBalloon)
  639.                                              nil)       ; don't display menu help while menu down
  640.                                       (nth (1- item-num) (slot-value menu 'item-list))))
  641.                            (string (and element (checked-help-string element))))
  642.                       (if (and (null element) (eq menu *apple-menu*))
  643.                         #xffff          ; pass through for system apple menu items
  644.                         (when string
  645.                           (show-balloon-string element string tip))))
  646.                     0)
  647.                 #xffff))))              ; return of #xffff means let the help manager handle it.
  648.       0))
  649.  
  650. (eval-when (compile load eval)
  651.   (let ((*warn-if-redefine* nil))
  652.     (defconstant _Pack14 #xa830))
  653. )
  654.  
  655. (defvar *old-pack14-trap-address* nil)
  656. (defvar *pack14-patch-pointer* nil)
  657.  
  658. (defun install-hmShowBalloon-patch ()
  659.   (when *help-manager-present*
  660.     (let ((p *pack14-patch-pointer*))
  661.       (when p
  662.         (#_SetTrapAddress :NewTool *old-pack14-trap-address*  _Pack14)
  663.         (setq *old-pack14-trap-address* nil
  664.               *pack14-patch-pointer* nil)
  665.         (#_DisposPtr p)))
  666.     (let* ((patch-vector *hmShowMenuBalloon-patch*)
  667.            (words (length patch-vector))
  668.            (p (#_NewPtr (* 2 words)))
  669.            (offset 0))
  670.       (declare (fixnum offset words))
  671.       (dotimes (i words)
  672.         (declare (fixnum i))
  673.         (setf (%get-word p offset) (uvref patch-vector i))
  674.         (incf offset 2))
  675.       (setq *old-pack14-trap-address* (#_GetTrapAddress :NewTool _Pack14)
  676.             *pack14-patch-pointer* p)
  677.       (setf (%get-ptr p 0) lisp-hmShowMenuBalloon
  678.             (%get-ptr p 4) *old-pack14-trap-address*)
  679.       (#_SetTrapAddress :NewTool (%inc-ptr p 8) _Pack14)
  680.       p)))
  681.  
  682. (defun start-hmShowBalloon-patch ()
  683.   (setq *old-pack14-trap-address* nil
  684.         *pack14-patch-pointer* nil)
  685.   (install-hmshowballoon-patch))
  686.  
  687. (pushnew 'start-hmshowballoon-patch *lisp-startup-functions*)
  688.  
  689. (install-hmshowballoon-patch)
  690.     
  691.  
  692. (provide :help-manager)
  693.  
  694.